home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr48
/
paswiz14.zip
/
SOURCE.ZIP
/
BCD.PAS
next >
Wrap
Pascal/Delphi Source File
|
1993-02-28
|
14KB
|
586 lines
{ +----------------------------------------------------------------------+
| |
| PasWiz Copyright (c) 1990-1993 Thomas G. Hanlin III |
| 3544 E. Southern Ave. #104, Mesa, AZ 85204 |
| |
| The Pascal Wizard's Library |
| |
+----------------------------------------------------------------------+
BCD math:
This collection of routines provides powerful support for BCD math.
Numbers may be up to 255 digits long, with a decimal point anywhere
you want it. Trig and other advanced functions are provided as well
as the more prosaic multiply, divide, subtract, and add.
}
UNIT BCD;
INTERFACE
VAR
LeftD, RightD: Integer;
FUNCTION BCDAbs (Nr: String): String;
FUNCTION BCDAdd (Nr1, Nr2: String): String;
FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
FUNCTION BCDCos (Nr: String): String;
FUNCTION BCDCot (Nr: String): String;
FUNCTION BCDCsc (Nr: String): String;
FUNCTION BCDDeg2Rad (Nr: String): String;
FUNCTION BCDDiv (Nr1, Nr2: String): String;
FUNCTION BCDe: String;
FUNCTION BCDFact (Num: Integer): String;
FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
FUNCTION BCDFrac (Nr: String): String;
FUNCTION BCDInt (Nr: String): String;
FUNCTION BCDMul (Nr1, Nr2: String): String;
FUNCTION BCDNeg (Nr: String): String;
FUNCTION BCDpi: String;
FUNCTION BCDPower (Nr: String; Power: Integer): String;
FUNCTION BCDRad2Deg (Nr: String): String;
FUNCTION BCDSec (Nr: String): String;
FUNCTION BCDSet (NumSt: String): String;
FUNCTION BCDSgn (Nr: String): Integer;
FUNCTION BCDSin (Nr: String): String;
FUNCTION BCDSqrt (Nr: String): String;
FUNCTION BCDSub (Nr1, Nr2: String): String;
FUNCTION BCDTan (Nr: String): String;
{ --------------------------------------------------------------------------- }
IMPLEMENTATION
{$F+}
{ various helper routines in assembly language }
PROCEDURE BCDAdd1 (VAR Nr1: String; Nr2: String); external;
PROCEDURE BCDDiv1L (VAR Nr: String); external;
PROCEDURE BCDDiv1R (VAR Nr: String); external;
PROCEDURE BCDMul1 (VAR Nr: String; Multiplier: Byte); external;
PROCEDURE BCDSub1 (VAR Nr: String); external;
FUNCTION BCDAbs; external;
FUNCTION BCDSgn; external;
{$L BCDABS}
{$L BCDADD1}
{$L BCDDIV1L}
{$L BCDDIV1R}
{$L BCDMUL1}
{$L BCDSGN}
{$L BCDSUB1}
{ local function: complement a number }
FUNCTION Complement (Nr: String): String;
VAR
St: String;
BEGIN
St := Nr;
BCDSub1(St);
Complement := St;
END;
{ local func: create a string of nulls }
FUNCTION NullDupe (DupeCount: Integer): String;
VAR
tmp: Integer;
St: String;
BEGIN
St := '';
FOR tmp := 1 TO DupeCount DO
St := St + CHR(0);
NullDupe := St;
END;
{ addition }
FUNCTION BCDAdd (Nr1, Nr2: String): String;
VAR
Sign1, Sign2, N1, N2: String;
BEGIN
Sign1 := Copy(Nr1, 1, 1);
Sign2 := Copy(Nr2, 1, 1);
N1 := Copy(Nr1, 2, 255);
N2 := Copy(Nr2, 2, 255);
IF (Sign1 = Sign2) THEN BEGIN
BCDAdd1 (N1, N2);
BCDAdd := Sign1 + N1; END
ELSE IF (Sign1 = '-') THEN
BCDAdd := BCDSub(Nr2, ' ' + N1)
ELSE
BCDAdd := BCDSub(Nr1, ' ' + N2);
END;
{ compare two numbers }
FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
VAR
Sign1, Sign2: String;
BEGIN
Sign1 := Copy(Nr1, 1, 1);
Sign2 := Copy(Nr2, 1, 1);
IF Sign1 = Sign2 THEN
BCDCompare := BCDSgn(BCDSub(' ' + Copy(Nr1, 2, 255), ' ' + Copy(Nr2, 2, 255)))
ELSE IF (Sign1 = '-') THEN
BCDCompare := -1
ELSE
BCDCompare := 1;
END;
{ cosine }
FUNCTION BCDCos (Nr: String): String;
VAR
One, Two, St, Result, I, X2: String;
BEGIN
One := BCDSet('1');
Two := BCDSet('2');
St := One;
Result := One;
I := Two;
X2 := BCDMul(Nr, Nr);
WHILE BCDSgn(St) <> 0 DO BEGIN
St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
Result := BCDAdd(Result, St);
I := BCDAdd(I, Two);
END;
BCDCos := Result;
END;
{ cotangent }
FUNCTION BCDCot (Nr: String): String;
BEGIN
BCDCot := BCDDiv(BCDCos(Nr), BCDSin(Nr));
END;
{ cosecant }
FUNCTION BCDCsc (Nr: String): String;
BEGIN
BCDCsc := BCDDiv(BCDSet('1'), BCDSin(Nr));
END;
{ convert degrees to radians }
FUNCTION BCDDeg2Rad (Nr: String): String;
BEGIN
BCDDeg2Rad := BCDDiv(BCDMul(Nr, BCDpi), BCDSet('180'));
END;
{ division }
FUNCTION BCDDiv (Nr1, Nr2: String): String;
VAR
Sign1, Sign2, N1, N2, Result, ShiftTrack: String;
Flip, Ready: Boolean;
BEGIN
IF BCDSgn(Nr2) = 0 THEN
BCDDiv := ''
ELSE IF BCDSgn(Nr1) = 0 THEN
BCDDiv := Nr1
ELSE BEGIN
Sign1 := Copy(Nr1, 1, 1);
Sign2 := Copy(Nr2, 1, 1);
N1 := BCDAbs(Nr1);
N2 := BCDAbs(Nr2);
Result := BCDSet('0');
ShiftTrack := BCDSet('1');
REPEAT
Flip := FALSE;
Ready := FALSE;
REPEAT
CASE BCDCompare(N2, N1) OF
-1: BEGIN
BCDDiv1L(N2);
BCDDiv1L(ShiftTrack);
Flip := TRUE;
END;
0: Ready := TRUE;
1: BEGIN
BCDDiv1R(N2);
BCDDiv1R(ShiftTrack);
Ready := Flip;
END;
END;
IF BCDSgn(ShiftTrack) = 0 THEN Ready := TRUE;
UNTIL Ready;
Result := BCDAdd(Result, ShiftTrack);
N1 := BCDSub(N1, N2);
UNTIL (BCDSgn(ShiftTrack) = 0) OR (BCDSgn(N1) = 0);
IF Sign1 = Sign2 THEN
BCDDiv := Sign1 + Copy(Result, 2, 255)
ELSE
BCDDiv := '-' + Copy(Result, 2, 255);
END;
END;
{ the constant "e" }
FUNCTION BCDe: String;
VAR
St: String;
BEGIN
St := '2.718281828459045235360287471352662497757247093699959574966';
St := St + '9676277240766303535475945713821785251664274274663919320031';
BCDe := BCDSet(St);
END;
{ factorial }
FUNCTION BCDFact (Num: Integer): String;
VAR
One, Result, Mult: String;
N: Integer;
BEGIN
One := BCDSet('1');
Result := One;
Mult := BCDSet('2');
FOR N := 2 TO Num DO BEGIN
Result := BCDMul(Result, Mult);
Mult := BCDAdd(Mult, One);
END;
BCDFact := Result;
END;
{ format a number into a text string }
FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
VAR
L, R, Sign, T, St: String;
tmp, ch: Integer;
BEGIN
Sign := Copy(Nr, 1, 1);
L := Copy(Nr, 2, LeftD);
R := Copy(Nr, Length(Nr) - RightD + 1, RightD);
WHILE Copy(L, 1, 1) = CHR(0) DO
L := Copy(L, 2, 255);
IF Length(L) = 0 THEN
L := CHR(0);
IF Odd(FormatType) AND (Length(L) > 3) THEN BEGIN
T := Copy(L, 1, Length(L) - 3);
L := Copy(L, Length(L) - 2, 3);
WHILE Length(T) > 3 DO BEGIN
L := Copy(T, Length(T) - 2, 3) + ',' + L;
T := Copy(T, 1, Length(T) - 3);
END;
L := T + ',' + L;
IF Copy(L, 1, 1) = ',' THEN L := Copy(L, 2, 255);
END;
IF Odd(FormatType SHR 1) THEN
L := '$' + L;
IF Odd(FormatType SHR 3) AND (Sign = ' ') THEN
Sign := '+';
R := Copy(R, 1, Abs(RightDigits));
IF RightDigits < 0 THEN
WHILE Copy(R, Length(R), 1) = CHR(0) DO
R := Copy(R, 1, Length(R) - 1);
IF Odd(FormatType SHR 2) THEN
R := R + Sign
ELSE
L := Sign + L;
St := L + '.' + R;
IF RightDigits = 0 THEN BEGIN
tmp := Pos('.', St);
St := Copy(St, 1, tmp - 1) + Copy(St, tmp + 1, 255);
END;
FOR tmp := 1 TO Length(St) DO BEGIN
ch := ORD(St[tmp]);
IF ch < 10 THEN
St[tmp] := CHR(ch + 48);
END;
BCDFormat := St;
END;
{ keep only the digits to the right of the decimal point }
FUNCTION BCDFrac (Nr: String): String;
VAR
St: String;
tmp: Integer;
BEGIN
St := BCDFormat(Nr, 0, RightD);
tmp := Pos('.', St);
IF tmp > 0 THEN
St := '0' + Copy(St, tmp, 255)
ELSE
St := '0';
BCDFrac := BCDSet(St);
END;
{ keep only the digits to the left of the decimal point }
FUNCTION BCDInt (Nr: String): String;
BEGIN
BCDInt := BCDSet(BCDFormat(Nr, 0, 0));
END;
{ multiply }
FUNCTION BCDMul (Nr1, Nr2: String): String;
VAR
ch: Byte;
TotalD, tmp2, ShiftVal: Integer;
Sign, N1, N2, Total, St: String;
BEGIN
TotalD := LeftD + RightD;
IF Copy(Nr1, 1, 1) = Copy(Nr2, 1, 1) THEN
Sign := ' '
ELSE
Sign := '-';
N1 := Copy(Nr1, 2, 255);
N2 := Copy(Nr2, 2, 255);
Total := BCDSet('0');
FOR tmp2 := Length(N2) DOWNTO 1 DO BEGIN
ch := ORD(N2[tmp2]);
IF ch <> 0 THEN BEGIN
St := N1;
BCDMul1(St, ch);
IF tmp2 > TotalD - RightD THEN BEGIN
ShiftVal := RightD - (TotalD - tmp2);
St := ' ' + NullDupe(ShiftVal) + Copy(St, 1, Length(St) - ShiftVal);
END
ELSE BEGIN
ShiftVal := LeftD - tmp2;
St := ' ' + Copy(St, ShiftVal + 1, 255) + NullDupe(ShiftVal);
END;
Total := BCDAdd(Total, St);
END;
END;
BCDMul := Sign + Copy(Total, 2, 255);
END;
{ negate }
FUNCTION BCDNeg (Nr: String): String;
BEGIN
CASE BCDSgn(Nr) OF
-1: BCDNeg := ' ' + Copy(Nr, 2, 255);
0: BCDNeg := Nr;
1: BCDNeg := '-' + Copy(Nr, 2, 255);
END;
END;
{ the constant "pi" }
FUNCTION BCDpi: String;
VAR
St: String;
BEGIN
St := '3.1415926535897932384626433832795028841971';
St := St + '6939937510582097494459230781640628620899';
St := St + '8628034825342117067982148086513282306647';
St := St + '0938446095505822317253594081284811174502';
St := St + '8410270193852110555964462294895493038196';
St := St + '4428810975665933446128475648233786783165';
St := St + '2712019091456';
BCDpi := BCDSet(St);
END;
{ raise a number to a power }
FUNCTION BCDPower (Nr: String; Power: Integer): String;
VAR
P: Integer;
Sign, PSeq, Result: String;
BEGIN
IF Power <= 0 THEN
BCDPower := BCDSet('1')
ELSE BEGIN
Sign := Copy(Nr, 1, 1);
P := Power;
Result := BCDSet('1');
PSeq := BCDAbs(Nr);
WHILE P > 0 DO BEGIN
IF Odd(P) THEN Result := BCDMul(Result, PSeq);
P := P DIV 2;
PSeq := BCDMul(PSeq, PSeq);
END;
IF Odd(Power) THEN
BCDPower := Sign + Copy(Result, 2, 255)
ELSE
BCDPower := Result;
END;
END;
{ convert radians to degrees}
FUNCTION BCDRad2Deg (Nr: String): String;
BEGIN
BCDRad2Deg := BCDDiv(BCDMul(Nr, BCDSet('180')), BCDpi);
END;
{ secant }
FUNCTION BCDSec (Nr: String): String;
BEGIN
BCDSec := BCDDiv(BCDSet('1'), BCDCos(Nr));
END;
{ convert a text string to a BCD number }
FUNCTION BCDSet (NumSt: String): String;
VAR
tmp, ch: Integer;
St, Sign, L, R: String;
BEGIN
St := NumSt;
WHILE Copy(St, 1, 1) = ' ' DO
St := Copy(St, 2, 255);
WHILE Copy(St, Length(St), 1) = ' ' DO
St := Copy(St, 1, Length(St) - 1);
FOR tmp := 1 TO Length(St) DO BEGIN
ch := ORD(St[tmp]);
IF (ch >= 48) AND (ch <= 57) THEN
St[tmp] := CHR(ch - 48);
END;
IF Copy(St, 1, 1) = '-' THEN BEGIN
Sign := '-';
St := Copy(St, 2, 255);
END
ELSE
Sign := ' ';
tmp := Pos('.', St);
IF tmp > 0 THEN BEGIN
L := Copy(St, 1, tmp - 1);
R := Copy(St, tmp + 1, 255);
END
ELSE BEGIN
L := St;
R := '';
END;
L := NullDupe(LeftD) + L;
L := Copy(L, Length(L) - LeftD + 1, LeftD);
R := Copy(R + NullDupe(RightD), 1, RightD);
BCDSet := Sign + L + R;
END;
{ sine }
FUNCTION BCDSin (Nr: String): String;
VAR
St, Result, One, Two, I, X2: String;
BEGIN
St := Nr;
Result := Nr;
One := BCDSet('1');
Two := BCDSet('2');
I := BCDSet('3');
X2 := BCDMul(Nr, Nr);
WHILE BCDSgn(St) <> 0 DO BEGIN
St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
Result := BCDAdd(Result, St);
I := BCDAdd(I, Two);
END;
BCDSin := Result;
END;
{ square root }
FUNCTION BCDSqrt (Nr: String): String;
VAR
Two, Est1, Est2: String;
BEGIN
IF Copy(Nr, 1, 1) = '-' THEN
BCDSqrt := ''
ELSE BEGIN
Two := BCDSet('2');
Est2 := BCDDiv(Nr, Two);
REPEAT
Est1 := Est2;
Est2 := BCDDiv(BCDAdd(Est1, BCDDiv(Nr, Est1)), Two);
UNTIL BCDCompare(Est1, Est2) = 0;
BCDSqrt := Est2;
END;
END;
{ subtraction }
FUNCTION BCDSub (Nr1, Nr2: String): String;
VAR
Sign1, Sign2, N1, N2: String;
BEGIN
Sign1 := Copy(Nr1, 1, 1);
Sign2 := Copy(Nr2, 1, 1);
N1 := Copy(Nr1, 2, 255);
N2 := Copy(Nr2, 2, 255);
IF Sign1 = Sign2 THEN BEGIN
BCDAdd1(N1, Complement(N2));
IF ORD(N1[1]) = 9 THEN
IF Sign1 = '-' THEN
N1 := ' ' + Complement(N1)
ELSE
N1 := '-' + Complement(N1)
ELSE
N1 := Sign1 + N1;
BCDSub := N1;
END
ELSE BEGIN
BCDAdd1(N1, N2);
BCDSub := Sign1 + N1;
END;
END;
{ tangent }
FUNCTION BCDTan (Nr: String): String;
BEGIN
BCDTan := BCDDiv(BCDSin(Nr), BCDCos(Nr));
END;
{ ----------------------- initialization code --------------------------- }
BEGIN
LeftD := 20; { digits to the left of the decimal }
RightD := 11; { digits to the right of the decimal }
END.